Chip 2004 April/CMCD0404.ISO/Software/Shareware/Programare/sharp/wwwSharp_setup.exe/{app}/Examples/RssPublisher/Source/RSSpub.vbs

Text File | 2004-02-04 | 9.9 KB | 374 lines

' ============================================
' this file contains functions that you can use to fill a string with
' ASPRSS-compliant XML. This string can be stored in the file RSS.xml
' or sent directly to the client.
'
' home:    http://ASPRSS.com/
' discuss:  http://www.asplists.com/asplists/asprss.asp
' validate: http://ASPRSS.com/RSSform.asp
' ============================================
Dim sRSSXML            ' contains resulting XML
Dim sItems                ' contains contents of <items> element

' ============================================
' Returns indentation string from indent level
' ============================================
Function GetIndentString(iIndent)
    GetIndentString = String(2*iIndent, " ")
End Function

' ============================================
' adds header to sRSSXML
'
' The following parameters are mandatory:
'  sSiteTitle, sSiteDescr, sSiteURL
'
' The following parameters are optional:
'  sSiteDetails, sImageURL, sAuthorNames, sAuthorEmails
'  sFurtherReading
'
' Note: sAuthorNames, sAuthorEmails and sFurtherReading can contain
'  multiple entries, separated by |.
'
' Both sAuthorNames and sAuthorEmails *must* have the same
'  number of  elements, but elements can be empty if required.
' ============================================
Function RSSheader ( sSiteTitle, sSiteDescr, sSiteURL, sSiteDetails, sImageURL, sFurtherReading, sAuthorNames, sAuthorEmails )

    If Len ( sSiteTitle ) = 0 Or Len ( sSiteDescr ) = 0 Or Len ( sSiteURL ) = 0 Then
        'Response.Write ( "<p>Must pass sSiteTitle,sSiteDescr,sSiteURL into RSSheader<p>" )
        RSSheader = False
        Exit Function
    End If

    ' add header to XML string
    sRSSXML = "<?xml version=""1.0""?>" & chr(10)

    sRSSXML = sRSSXML & "<rdf:RDF" & chr(10)

    ' specify namespaces
    sRSSXML = sRSSXML & "  xmlns:rdf=""http://www.w3.org/1999/02/22-rdf-syntax-ns#""" & chr(10)
    sRSSXML = sRSSXML & "  xmlns:dc=""http://purl.org/dc/elements/1.1/""" & chr(10)
    sRSSXML = sRSSXML & "  xmlns:fr=""http://ASPRSS.com/fr.html""" & chr(10)
    sRSSXML = sRSSXML & "  xmlns:pa=""http://ASPRSS.com/pa.html""" & chr(10)
    sRSSXML = sRSSXML & "  xmlns=""http://purl.org/rss/1.0/"">" & chr(10)

    ' specify channel
    sRSSXML = sRSSXML & "<channel rdf:about=""" + sSiteURL + """>" & chr(10)

        If Not RSStag ( sRSSXML, "title", sSiteTitle, 1 ) Then
            RSSheader = False
            Exit Function
        End If

        If Not RSStag ( sRSSXML, "link", sSiteURL, 1 ) Then
            RSSheader = False
            Exit Function
        End If

        If Not RSStag ( sRSSXML, "description", sSiteDescr, 1 ) Then
            RSSheader = False
            Exit Function
        End If

        If Len ( sSiteDetails ) > 0 Then
            If Not RSStag ( sRSSXML, "dc:publisher", sSiteDetails, 1 ) Then
                RSSheader = False
                Exit Function
            End If
        End If

        If Len ( sFurtherReading ) > 0 Then
            If  Not RSStag ( sRSSXML, "fr:url", sFurtherReading, 1 ) Then
                RSSheader = False
                Exit Function
            End If
        End If

        If Len ( sAuthorNames ) > 0 Then
            If Not RSSauthor ( sRSSXML, sAuthorNames, sAuthorEmails, 1 ) Then
                RSSheader = False
                Exit Function
            End If
        End If

        If Len ( sImageURL ) > 0 Then
            sRSSXML = sRSSXML & GetIndentString(1) & "<image rdf:resource=""" + sImageURL + """ />" & chr(10)
        End If

        ' add empty <items>, filled in later by RSSfooter()
        If Not RSStag ( sRSSXML, "items", "", 1 ) Then
            RSSheader = False
            Exit Function
        End If

        ' initialize <items> store
        sItems = ""

    ' close channel
    sRSSXML = sRSSXML & "</channel>" & chr(10)

    ' add optional image
    If Len ( sImageURL ) > 0 Then

        sRSSXML = sRSSXML & GetIndentString(1) & "<image rdf:about=""" + sImageURL + """>" & chr(10)

            If Not RSStag ( sRSSXML, "title", sSiteTitle, 2 ) Then
                RSSheader = False
                Exit Function
            End If

            If Not RSStag ( sRSSXML, "url", sImageURL, 2 ) Then
                RSSheader = False
                Exit Function
            End If

            If Not RSStag ( sRSSXML, "link", sSiteURL, 2 ) Then
                RSSheader = False
                Exit Function
            End If

        sRSSXML = sRSSXML & GetIndentString(1) & "</image>" & chr(10)

    End If

    RSSheader = True

End Function

' ============================================
' adds item to sRSSXML
'
' The following parameters are mandatory:
'  sTitle, sDescr, sURL
'
' The following parameters are optional:
'  sDate, sCategory, sKeywords, sAuthorNames, sAuthorEmails
'
' Note: sAuthorNames and sAuthorEmails can contain multiple entries,
'  separated by |. Both *must* have the same number of  elements,
'  but elements can be empty if required.
'
' sKeywords can contain multiple keywords, but all will be grouped
'  in a single element. Keywords should be seperated by commas.
' ============================================
Function RSSitem ( sTitle, sDescr, sURL, sDate, sCategory, sKeywords, sAuthorNames, sAuthorEmails )

    Dim dDate
    Dim sMonth
    Dim sDay
    Dim sValidDate
    'VVV - create each item as string and later add it to sRSSXML, better memory usage
    Dim sItem

    If Len ( sTitle ) = 0 Or Len ( sDescr ) = 0 Or Len ( sURL ) = 0 Then
        'Response.Write ( "<p>Must pass sTitle,sDescr,sURL into RSSitem<p>" )
        RSSitem = False
        Exit Function
    End If

    ' start new <resource>
    sItem = sItem & GetIndentString(1) & "<item rdf:about=""" & sURL & """>" & chr(10)

        If Not RSStag ( sItem, "title", sTitle, 2 ) Then
            RSSitem = False
            Exit Function
        End If

        If Not RSStag ( sItem, "description", sDescr, 2 ) Then
            RSSitem = False
            Exit Function
        End If

        If Not RSStag ( sItem, "link", sURL, 2 ) Then
            RSSitem = False
            Exit Function
        End If

        If Len ( sDate ) > 0 Then
            ' make it a valid date according to
            ' http://www.w3.org/TR/NOTE-datetime

            ' get a date object
            dDate = DateValue ( sDate )

            ' make sure month is 2 digits
            sMonth = Right ( "0" & Month ( dDate ), 2)

            ' make sure day is 2 digits
            sDay = Right ( "0" & Day ( dDate ), 2)

            ' make valid date
            sValidDate = Year ( dDate ) & "-" & sMonth & "-" & sDay

            If Not RSStag ( sItem, "dc:date", sValidDate, 2 ) Then
                RSSitem = False
                Exit Function
            End If
        End If

        If Len ( sCategory ) > 0 Then
            If Not RSStag ( sItem, "pa:category", sCategory, 2 ) Then
                RSSitem = False
                Exit Function
            End If
        End If

        If Len ( sKeywords ) > 0 Then
            If Not RSStag ( sItem, "pa:keywords", sKeywords, 2 ) Then
                RSSitem = False
                Exit Function
            End If
        End If

        If Len ( sAuthorNames ) > 0 Then
            If Not RSSauthor ( sItem, sAuthorNames, sAuthorEmails, 2 ) Then
                RSSitem = False
                Exit Function
            End If
        End If

    ' add to <items> store
    sItems = sItems & GetIndentString(3) & "<rdf:li rdf:resource=""" & sURL & """/>" & chr(10)

    sItem = sItem & GetIndentString(1) & "</item>" & chr(10)

    sRSSXML = sRSSXML & sItem
    RSSitem = True

End Function

' ============================================
' adds footer to sRSSXML
' ============================================
Function RSSfooter ( )

    Dim nItemsPos

    sRSSXML = sRSSXML & "</rdf:RDF>" & chr(10)

    ' fill in <items> element
    nItemsPos = InStr ( sRSSXML, "</items>" )

    If nItemsPos = 0 Then
        'Response.Write ( "<p>Missing <items> element<p>" )
        RSSfooter = False
        Exit Function
    End If

    sRSSXML = Left ( sRSSXML, nItemsPos-1 ) & chr(10) & GetIndentString(2) & "<rdf:Seq>" & chr(10) & _
        sItems & GetIndentString(2) & "</rdf:Seq>" & chr(10) & GetIndentString(1) & Mid ( sRSSXML, nItemsPos )

    RSSfooter = True

End Function

' ============================================
' stores sRSSXML to file
'
' The following parameters are mandatory:
'  sFilename
'
' note: requires write permission to file sFilename
' ============================================
Function RSSpersist ( sFilename )

    Dim oFSO
    Dim fFile

    ' create an instance of the FileSystemObject
    'Set oFSO = Server.CreateObject ( "Scripting.FileSystemObject" )
    Set oFSO = CreateObject ( "Scripting.FileSystemObject" )

    ' create file
    'Set fFile = oFSO.CreateTextFile ( Server.MapPath ( sFilename ) )
    Set fFile = oFSO.CreateTextFile ( sFilename )

    fFile.WriteLine ( sRSSXML )

    fFile.Close

    Set fFile = Nothing
    Set oFSO = Nothing

    RSSpersist = True

End Function

' ============================================
' INTERNAL USE ONLY - DO NOT CALL DIRECTLY
'
' store tag + value
'
' The following parameters are mandatory:
'  sTag, sValue
' ============================================
Function RSStag ( ByRef sXml, sTag, sValue, iIndent )

    Dim Reg
    Dim sStripped

    ' regular expression to remove HTML
    Set Reg = New Regexp
    Reg.Pattern = "<[^>]*>"
    Reg.Global = True

    sStripped = Reg.Replace ( sValue, "" )

    sXml = sXml & GetIndentString(iIndent) & "<" & sTag & ">" & sStripped & "</" & sTag & ">" & chr(10)

    RSStag = True

End Function

' ============================================
' INTERNAL USE ONLY - DO NOT CALL DIRECTLY
'
' store authors in <dc:creator>'s
'
' The following parameters are mandatory:
'  sAuthorNames, sAuthorEmails
'
' note: sName and sEmail *must* have the same number of  elements
' ============================================
Function RSSauthor ( ByRef sXml, sAuthorNames, sAuthorEmails, iIndent )

    Dim sNames
    Dim sEmails
    Dim sName
    Dim sEmail
    Dim I

    sNames = Split ( sAuthorNames, "|" )
    sEmails = Split ( sAuthorEmails, "|" )

    If UBound ( sNames ) <> UBound ( sEmails ) Then
        'Response.Write ( "<p>Must pass equal number of elements to RSSauthor<p>" )
        RSSauthor = False
        Exit Function
    End If

    For I = 0 To UBound ( sNames )
        sXml = sXml & GetIndentString(iIndent) & "<dc:creator>"

            sName = sNames ( I )
            sEmail = sEmails ( I )

            ' add spaces and braces if both specified
            If Len ( sName ) > 0 Then
                If Len ( sEmail ) > 0 Then
                    sXml = sXml & sName & " (mailto:" & sEmail & ")"
                Else
                    sXml = sXml & sName
                End If
            Else
                sXml = sXml & "mailto:" & sEmail
            End If

        sXml = sXml & "</dc:creator>" & chr(10)
    Next

    RSSauthor = True

End Function